package Firepear::Carrot::DOM;

use warnings;
use strict;

use DBM::Deep;
use Storable;

use Firepear::Carrot::Util;

=head1 NAME

Firepear::Carrot::DOM - Implements the Carrot Document Object Model

=head1 VERSION

Version 1.000

=cut

our $VERSION = '1.000';

=head1 SYNOPSIS

This module is part of L<Firepear::Carrot> and is meant to be used from
within it.

=cut

=head1 CONSTRUCTOR AND SHUTDOWN

=head2 new

The constructor can be used to create wholly new DOMs or to reattach
to DOM datastores generated by earlier processing.

=head3 New Mode

Here, C<new> has two arguments, both required:

=over

=item C<root>

A hashref representing the preprocessed document pragma trigger attributes.

=item C<file>

The base filename to be used for the DOM's persistence files.

=back

Example:

    my $dom = Firepear::Carrot::DOM->new( root => \%attrs,
                                          file => '/file/name' );

Calls to C<new> set a L</status> and return C<undef> if they are
unsuccessful; one should always check the status of a newly-created
DOM object. (If the call is successful in all respects, the status
will be zero.)

=head3 Attach Mode

When working with processed document data stored via a L</detach>
call, only one argument is needed:

    my $dom = Firepear::Carrot::DOM->new( attach => '/file/name' );

The filename passed as the argument to C<attach> should be the same as
one given in an earlier C<new> call. If the persistence files cannot
be recovered, a status will be set and C<undef> will be returned (as
above).

=cut

sub new {
    my ($class,%args) = @_;

    $args{file} = $args{attach} if defined $args{attach};

    my $self = bless { dom  => { ptr => 0, text => '', tree => [], ids => {} },
		       file => $args{file},
                       s    => 0,
                       e    => 0,
                       nodetypes => { 'TRIGGER'  => 1, 'TAG'  => 2,
				      'VERBATIM' => 3, 'TEXT' => 4 } }, $class;

    $self->status(903) unless (ref $args{root} eq 'ARRAY' ||
			       defined $args{attach});
    $self->status(902) unless (defined $args{root} ||
			       defined $args{attach});
    $self->status(901) unless (defined $args{file});
    return $self if $self->error;

    # Connect to text array/database
    unless (defined $args{attach})
      { unlink $self->{file} if -e $self->{file} }
    eval { $self->{dom}{text} = DBM::Deep->new( file => $self->{file},
						type => DBM::Deep->TYPE_ARRAY,
						data_sector_size => 256 ); };
    unless (ref $self->{dom}{text} eq 'DBM::Deep::Array')
      { $self->status(905); return $self }

    if (defined $args{attach}) {
	# Get DOM tree back if in attach mode
	my $storable = 0;
	eval { $storable = retrieve($args{attach} . '.dom') };
	unless ($storable) { $self->status(904); return $self }
	$self->{dom}{tree} = $storable;
    } else {
	# no? we're new. stow the document trigger
	$self->{dom}{tree}[0] = { type    => 'TRIGGER',
				  element => 'document',
				  parent  => 0 };
        $self->nodeattrs(0, $args{root});
    }

    return $self;
}

=head2 detach

Handles end-of-session housekeeping; should be called when a program
or module is done with the DOM object.

=head3 Retain Mode

This writes the DOM tree out to mass storage using L<Storable>, and
leaves the DOM's text storage file in plave. It is the default.

    $dom->detach( mode => 'retain' );
    $dom->detach; # same thing

=head3 Discard Mode

If processing has been completed or aborted and you wish to remove the
working files, call C<discard> as:

    $dom->detach( mode => 'discard' );

Discard mode will be enforced if an internal error has been set.

=cut

sub detach {
    my ($self, %args) = @_;
    my $tiefile = $self->{file};

    $args{mode} = 'retain' unless (defined $args{mode});
    $args{mode} = 'detach' if $self->error;

    if ($args{mode} eq 'discard') {
        unlink <$tiefile*>;
    } else {
        store $self->{dom}{tree}, "$tiefile.dom";
    }
}


=head1 NODE ACCESSOR METHODS

=head2 add

Creates a new document node. Returns the id of the newly created node
on success; returns C<undef> and sets a status code on failure.

    $dom->add( type    => $node_type,
               finfo   => \@fileinfo,
               element => $element_name,
               id      => $user_identifier,
               parent  => $pid,
               attrs   => \@attributes,
               content => $content,
             );

=over

=item C<type>

Required. Must be one of the valid node types.

=item C<finfo>

Required. A reference to a two-element list giving the source file
number and line number within that file for node being created.

    finfo => [2, 309]

This data can be had from the L<Lexer|Firepear::Carrot::Lexer>.

=item C<element>

Required, except for TEXT nodes, where it is illegal. This is the
element name of the tag, trigger, or verbatim chunk being represented.

       .--- element
       |
       V
    [[foo;bar baz;quux

=item C<id>

Optional except for TEXT nodes, where it is illegal. This is the
user-assigned, B<unique> identifier/mnemonic for the node being
created.

           .--- id
           |
           V
    [[foo;bar baz;quux

=item C<parent>

Optional; defaults to the current node. This is the node id of the
parent of the node being created.

=item C<attrs>

Optional; illegal for TEXT nodes. Attributes are given as a reference
to a list which represents a series of key/value pairs.

    attrs => [ 'author', 'J. Random Hacker', 'author',
               'George P. Burdell', 'date', '2007-12-29',
               'version', 2.2, 'author', 'Ramona Cartwright' ]

=item C<content>

Required for TEXT nodes; illegal for all others. This is the actual
text of a portion of the source document.

=back

=cut

sub add {
    my ($self, $incoming) = @_;
    return undef if $self->error;

    # validate nodetype, pid, and finfo
    unless (defined $incoming->{type})
      { $self->status(101); return undef }
    unless ($self->validtype($incoming->{type}))
      { $self->status(102); return undef }

    my $pid = defined $incoming->{parent} ?
      $incoming->{parent} : $self->{dom}{ptr};
    unless ($self->validnode($pid)) { $self->status(106); return undef }

    unless ($incoming->{finfo}) { $self->status(107); return undef }

    # create node
    my $node = { parent => $pid, cids => [], type => $incoming->{type},
		 finfo  => $incoming->{finfo}, };
    push @{ $self->{dom}{tree} }, $node;

    # push node onto parent's cids array
    my $id = $#{$self->{dom}{tree}};
    $self->nodechildren($pid, $id);

    # set various things if we have them
    $self->nodename($id, $incoming->{element}) if defined $incoming->{element};
    $self->nodeattrs($id, $incoming->{attrs})
      if defined $incoming->{attrs};
    $self->nodeid($id, $incoming->{refid})
      if defined $incoming->{refid};
    $self->nodecontent($id, $incoming->{content}) # this should go LAST
      if defined $incoming->{content};

    unless ($self->status) {
	# content is required for TEXT nodes
	if ($self->{dom}{tree}[$id]{type} eq 'TEXT') {
          $self->status(104)
            unless (defined $self->{dom}{tree}[$id]{cids}[0]);
        }

	# name required on non-TEXT nodes
	if ($self->{dom}{tree}[$id]{type} ne 'TEXT') {
	  $self->status(105)
            unless (defined $self->{dom}{tree}[$id]{element});
        }
    }

    if ($self->status)
      { $self->detach; return undef }

    return $id;
}


=head2 nodeattrs

Called with no arguments, nodeattrs returns a hashref containing the
attributes set on the current node.

Called with one argument (a node id), a hashref of the attributes
belonging to the specified node will be returned

    my $attrs = $dom->nodeattrs($nodeid);

Called with two arguments (node id and a listref of attribute
key/value pairs), it adds the given attributes to the specified node.

    $dom->nodeattrs($nodeid, \@attribs);

Returns C<undef> and sets a status code on error.

=cut

sub nodeattrs {
    my ($self,$node,$attrs) = @_;
    return undef if $self->error;

    # get the nodeid one way or another and validate it
    $node = $self->{dom}{ptr} unless (defined $node);
    unless ($self->validnode($node)) { $self->status(301); return undef }

    if (defined $attrs) {
	# we're adding attributes. check the formatting and that we're not
	# operating on a TEXT node
	unless (ref $attrs eq 'ARRAY') { $self->status(401); return undef }
	if ($self->{dom}{tree}[$node]{type} eq 'TEXT')
	  { $self->status(402); return undef }

	while (scalar @$attrs >= 2) {
	    # shift off key/value pairs, two-by-two
	    my $key = shift @$attrs; my $value = shift @$attrs;
	    if (defined $self->{dom}{tree}[$node]{attrs}{$key}) {
		if (ref $self->{dom}{tree}[$node]{attrs}{$key} eq 'ARRAY') {
		    # if the key already exists and is a listref, push on
		    push @{ $self->{dom}{tree}[$node]{attrs}{$key} }, $value;
		} else {
		    # if it exists, but is a scalar, convert to listref
		    $self->{dom}{tree}[$node]{attrs}{$key} =
		      [ $self->{dom}{tree}[$node]{attrs}{$key}, $value ];
		}
	    } else {
		# if it doesn't exist, just assign as scalar
		$self->{dom}{tree}[$node]{attrs}{$key} = $value;
	    }
	}
	return;
    } else {
	# just hand over the attrs so long as everything's ok
	unless (defined $self->{dom}{tree}[$node]{attrs}) {
	    $self->status(304); return undef;
	}
	return $self->{dom}{tree}[$node]{attrs};
    }
}

=head2 nodechildren

Called with no arguments, returns a listref containing the node ids of
the children of the current node.

Called with one argument (node id), returns a listref for the specified
node.

    my $children = $dom->nodechildren($nodeid);

Called with two arguments (id, child), appends the specified child
to the node's list.

    $dom->nodechildren($nodeid, $child);

In all cases, returns C<undef> and sets a status code if there is an
error.

=cut

sub nodechildren {
    my ($self,$node,$child) = @_;
    return undef if $self->error;

    $node = $self->{dom}{ptr} unless (defined $node);
    unless ($self->validnode($node)) { $self->status(301); return undef }

    my $type = $self->{dom}{tree}[$node]{type};

    if (defined $child) {
      unless ($self->validnode($child, $type))
        { $self->status(301); return undef }
      push @{ $self->{dom}{tree}[$node]{cids} }, $child;
      return 1;
    } else {
      unless (scalar @{ $self->{dom}{tree}[$node]{cids} })
        { $self->status(303); return undef }
      return $self->{dom}{tree}[$node]{cids};
    }
}

=head2 nodecontent

Called with no arguments, returns the textual content of the current
node.

Called with one argument (node id), returns the text of the specified
node.

    my $content = $dom->nodecontent($nodeid);

Called with two arguments (id, content), sets the content of the
specified node to the given text. This is only legal if the node
does not already have content associated with it. It is only legal for
TEXT nodes, and is required for all TEXT nodes.

    $dom->nodename($nodeid, $content);

In all cases, returns C<undef> and sets a status code if there is an
error.

=cut

sub nodecontent {
  my ($self,$node,$content) = @_;
  return undef if $self->error;

  $node = $self->{dom}{ptr} unless (defined $node);
  unless ($self->validnode($node)) { $self->status(301); return undef; }

  if (defined $content) {
    unless ($self->{dom}{tree}[$node]{type} eq "TEXT")
      { $self->status(403); return undef }
    if (defined $self->{dom}{tree}[$node]{cids}[0])
      { $self->status(404); return undef }
    push @{ $self->{dom}{text} }, $content;
    $self->nodechildren($node, $#{ $self->{dom}{text} });
  } else {
    unless ($self->{dom}{tree}[$node]{type} eq "TEXT")
      { $self->status(302); return undef }
    my $textnode = $self->nodechildren($node);
    return $self->{dom}{text}[ $textnode->[0] ];
  }
}

=head2 nodename

Called with no arguments, returns the name of the current node.

Called with one argument (node id), returns the name of the specified
node.

    my $name = $dom->nodename($nodeid);

Called with two arguments (id, name), sets the name of the specified
node to the specified name. This is only legal if the node does not
already have a name. It is not legal for TEXT nodes, and is required
for all non-TEXT nodes.

    $dom->nodename($nodeid, $name);

In all cases, returns C<undef> and sets a status code if there is an
error.

=cut

sub nodename {
    my ($self,$node,$name) = @_;
    return undef if $self->error;

    $node = $self->{dom}{ptr} unless (defined $node);
    unless ($self->validnode($node)) { $self->status(301); return undef; }

    if (defined $name) {
	if ($self->{dom}{tree}[$node]{type} eq "TEXT")
	  { $self->status(402); return undef }
	if (defined $self->{dom}{tree}[$node]{element})
	  { $self->status(404); return undef }
	$self->{dom}{tree}[$node]{element} = $name;
    } else {
	unless (defined $self->{dom}{tree}[$node]{element})
	  { $self->status(305); return undef; }
	return $self->{dom}{tree}[$node]{element};
    }
}

=head2 nodeid

Called with no arguments, returns the (optional, user-assigned,
arbitrary-but-unique, textual, for internal reference purposes) id of
the current node.

Called with one argument (numeric node id), returns the textual id of
the specified node.

    my $textid = $dom->nodeid($numid);

Called with two arguments (numid, textid), sets the textual id of the
specified node to the specified value. This is only legal if the node
does not already have a name, and the specified value must be unique
within the document.

    $dom->nodeid($numid, $textid);

In all cases, returns C<undef> and sets a status code if there is an
error.

=cut

sub nodeid {
    my ($self,$node,$id) = @_;
    return undef if $self->error;

    $node = $self->{dom}{ptr} unless (defined $node);
    unless ($self->validnode($node)) { $self->status(301); return undef; }
    if (defined $id) {
	if ($self->{dom}{tree}[$node]{type} eq 'TEXT')
	  { $self->status(402); return undef }
	if (defined $self->{dom}{tree}[$node]{refid})
	  { $self->status(404); return undef }
	if (defined $self->{dom}{ids}{$id})
	  { $self->status(108); return undef }
	$self->{dom}{tree}[$node]{refid} = $id;
	$self->{dom}{ids}{$id} = 1;
    } else {
	unless (defined $self->{dom}{tree}[$node]{refid})
	  { $self->status(306); return undef; }
	return $self->{dom}{tree}[$node]{refid};
    }
}

=head2 nodeparent

Returns the node id of the parent of the specified node. If no node is
specified current node will be used.

    my $pid = $dom->nodeparent($nodeid);

Returns C<undef> and sets a status code if the specified node does not
exist.

=cut

sub nodeparent {
    my ($self,$node) = @_;
    return undef if $self->error;

    $node = $self->{dom}{ptr} unless (defined $node);
    unless ($self->validnode($node)) { $self->status(301); return undef; }

    return $self->{dom}{tree}[$node]{parent};
}


=head2 nodefileinfo

Returns the file info (source file number and line number) of the
specified node. If no node is specified current node will be used.

    my $info = $dom->nodefileinfo($nodeid);

Returns C<undef> and sets a status code if the specified node does not
exist.

=cut

sub nodefileinfo {
    my ($self,$node) = @_;
    return undef if $self->error;

    $node = $self->{dom}{ptr} unless (defined $node);
    unless ($self->validnode($node)) { $self->status(301); return undef; }

    return $self->{dom}{tree}[$node]{finfo};
}



=head1 DOM UTILITY METHODS

=head2 curnode

Returns the current node id.

=cut

sub curnode {
    my ($self) = @_;
    return $self->{dom}{ptr};
}

=head2 jmp

Moves the DOM pointer to the specified node.

    $dom->jmp($node);    # jump to any given node
    $dom->jmp('parent'); # special: jump to parent of current node

Returns the new value of the node pointer on success; returns C<undef>
and sets a status code on failure.

=cut

sub jmp {
    my ($self,$node) = @_;

    return $self->curnode unless (defined $node);
    $node = $self->nodeparent if ($node eq 'parent');

    unless ($self->validnode($node)) { $self->status(201); return undef; }

    $self->{dom}{ptr} = $node;
    return $node;
}

=head2 validnode

Tests for the validity (existance) of a passed node id.

    $dom->validnode($nodeid)

Returns 1 if the node exists, zero if it does not, and C<undef> if
nothing was passed.

=cut

sub validnode {
    my ($self, $id, $ptype) = @_;

    return undef unless (defined $id);
    return 0 if ($id =~ /\D/);
    if (defined $ptype and $ptype eq 'TEXT') {
      return 0 unless (defined $self->{dom}{text}[$id]);
    } else {
      return 0 unless (defined $self->{dom}{tree}[$id]);
    }
    return 1;
}

=head2 validtype

Tests for the validity of a passed node type.

    $dom->validtype($type)

Returns 1 if the the node type is valid, zero if invalid, and C<undef>
if nothing was passed.

=cut

sub validtype {
    my ($self, $type) = @_;

    return undef unless (defined $type);
    return 0 unless (defined $self->{nodetypes}{$type});
    return 1;
}


=head1 AUTHOR

Shawn Boyette, C<< <mdxi@cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests at
L<http://carrot.googlecode.com>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 COPYRIGHT & LICENSE

Copyright 2006-2008 Shawn Boyette

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of the <ORGANIZATION> nor the names of its
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=cut

1; # End of Firepear::Carrot::DOM
